PC-X 1997 October/pcx14_9710.iso/swag/pointers.swg/0039_Very Large 2d arrays.pas

Pascal/Delphi Source File | 1996-11-29 | 8.1 KB | 296 lines

> > I'm working on a program where it would be very convenient
> >to use very large 2d arrays (40X3000 elements of type real, or
> >thereabouts) Is there any way to do this in TP7?
> >
> See URL in sig, but you may need BP since you call for 720000 bytes or
> thereabouts.  See also #FloatTypes.
>

{

Leopoldo Salvo Massieu. e-mail [e-mail]  -and-
[e-mail]

Object Storage is a zero-based array, just tell how many elements you
want to store and what's the size in bytes of each element (use sizeof).
It can allocate all heap available (also in Protected Mode). There's a
little demo down.
}

unit ALMACEN;

interface
         USES GRAPH;

         const Not_enough_memory = -100;
               Element_too_big = -101;
               File_Not_Found = -102;
               Error_Writing_File = -103;

         type pointerarray = array [0..16200] of pointer;

              {Zero-based array}
              PStorage = ^Storage;
              storage = object
                          private
                             elements_x_pointer, elem_size : word;
                             num_pointers, last_pointer_size : word;
                             data : ^pointerarray;
                             max : longint;
                             out_of_mem : boolean;
                          public
                             constructor init (num_elements : longint;
                                               element_size : word);
                             destructor done;
                             procedure put (pos : longint; p : pointer);
                             procedure get (pos : longint; VAR p :
pointer);
                             function save (filename : string) :
integer; virtual;
                             function load (filename : string) :
integer; virtual;
                        end;


implementation


(****************************************
object storage
****************************************)

const max_allocatable_ram : word = 65528;

constructor storage.init;
var memoria : longint;
    aux : longint;
    pneeded : word;
    i : integer;
begin
    memoria:=num_elements*element_size;
    elements_x_pointer:=max_allocatable_ram div element_size;
    max:=num_elements;
    pneeded:=(num_elements*element_size div max_allocatable_ram)+2;
    if (memoria+16000>memavail) or (elements_x_pointer=0)
       or (pneeded>16200) then
     begin
       Out_Of_Mem:=true;
       Fail;
     end;
    getmem (data, pneeded*sizeof(pointer));
    num_pointers:=0;
    for i:=1 to pneeded do data^[i]:=Nil;
    while num_elements>elements_x_pointer do
      begin
        getmem (data^[num_pointers], elements_x_pointer*element_size);
        fillchar (data^[num_pointers]^,elements_x_pointer*element_size,0);
        inc (num_pointers);
        dec (num_elements, elements_x_pointer);
      end;
    if (num_elements>0) then
     begin
       getmem (data^[num_pointers], num_elements*element_size);
       fillchar (data^[num_pointers]^, num_elements*element_size,0);
       last_pointer_size:=num_elements*element_size
     end
    else
       last_pointer_size:=elements_x_pointer*element_size;
    elem_size:=element_size;
end;

destructor storage.done;
var i : longint;
begin
   if num_pointers>0 then
    for i:=0 to num_pointers-1 do
     if data^[i]<>NIL then freemem (data^[i], elements_x_pointer*elem_size);
   if data^[num_pointers]<>nil then freemem (data^[num_pointers], last_pointer_size);
   if data<>NIL then freemem (data, num_pointers*sizeof(pointer));
   max:=-1;
end;

procedure storage.put;
type table = array [0..65528] of byte;
var numpunt : longint;
    desp : word;
begin
  if (pos>=0) and (pos<max) then
   begin
    numpunt:=pos div elements_x_pointer;
    desp:=(pos-numpunt*elements_x_pointer)*elem_size;
    move (p^, table(data^[numpunt]^)[desp], elem_size);
   end
  else
   inc(pos)
end;

procedure storage.get;
type table = array [0..65528] of byte;
var numpunt : longint;
    desp : word;
begin
  if (pos>=0) and (pos<max) then
   begin
    numpunt:=pos div elements_x_pointer;
    desp:=(pos-numpunt*elements_x_pointer)*elem_size;
    p:=addr(table(data^[numpunt]^)[desp]);
   end
  else
   halt (23)
end;

function storage.save;
var f : file;
    i, res : integer;
    escr : word;
begin
   assign (f, filename);
   {$I-}
      rewrite (f,1);
   {$I+}
   res:=ioresult;
   if res=0 then
    begin
     {$I-}
       blockwrite (f, elements_x_pointer, sizeof(elements_x_pointer));
       blockwrite (f, elem_size, sizeof(elem_size));
       blockwrite (f, num_pointers, sizeof(num_pointers));
       blockwrite (f, last_pointer_size, sizeof(last_pointer_size));
       blockwrite (f, max, sizeof(max));
     {$I+}
     res:=ioresult;
     if res<>0 then begin save:=res; exit; end;
     if num_pointers>0 then
      begin
        for i:=0 to num_pointers-1 do
         begin
          {$I-}
           blockwrite (f, data^[i]^, elements_x_pointer*elem_size,escr);
          {$I+}
          res:=ioresult; if res<>0 then begin write ('{#',res,',',escr,'}'); break; end
         end;
       if res=0 then
        begin
         {$I-}
           blockwrite (f, data^[num_pointers]^, last_pointer_size,  escr);
         {$I+}
         res:=ioresult; if res<>0 then begin write ('{@',res,',',escr,'}'); end
        end;
      end;
    end;
   save:=res;
   {$I-}
     close (f);
   {$I+}
   res:=ioresult;
end;

function storage.load;
var f : file;
    i, res : integer;
    lect,exp,es,np,lps :word;
    m : longint;
begin
   assign (f, filename);
   {$I-}
      reset (f,1);
   {$I+}
   res:=ioresult;
   if res<>0 then begin load:=res; exit; end;
   {$I-}
     blockread (f, exp, sizeof(elements_x_pointer));
     blockread (f, es, sizeof(elem_size));
     blockread (f, np, sizeof(num_pointers));
     blockread (f, lps, sizeof(last_pointer_size));
     blockread (f, m, sizeof(max));
   {$I+}
   res:=ioresult;
   if res<>0 then begin load:=res; exit; end;
   if ( (np>0) and (longint(exp)*(np-1)*es+lps+32000>memavail) ) or
      ( (np=0) and (lps+32000>memavail) ) then
       begin writeln; writeln ('np: ', np, 'exp: ', exp, 'es: ', es,'
             lps: ',lps); out_of_mem:=true; exit; end;
   done;
   elements_x_pointer:=exp; elem_size:=es; num_pointers:=np;
   last_pointer_size:=lps; max:=m;
   getmem (data, num_pointers*sizeof(pointer));
   if num_pointers>0 then for i:=0 to num_pointers-1 do
         getmem (data^[i], elements_x_pointer*elem_size);
   getmem (data^[num_pointers], last_pointer_size);
   out_of_mem:=false;
   if num_pointers>0 then
    begin
     for i:=0 to num_pointers-1 do
      begin
       {$I-}
        blockread (f, data^[i]^, elements_x_pointer*elem_size, lect);
       {$I+}
       res:=ioresult; if res<>0 then begin write ('{&',res,',',lect,'}'); break; end
      end;
     if res=0 then
      begin
       {$I-}
        blockwrite (f, data^[num_pointers]^, last_pointer_size);
       {$I+}
       res:=ioresult; if res<>0 then begin write ('{&',res,',',lect,'}'); end
      end;
    end;
   load:=res;
   {$I-}
     close (f);
   {$I+}
   res:=ioresult;
end;

end. {of unit almacen}



{and now a little demo (compile under protected mode or there will be
not enough heap}


uses almacen;

type  ptipe = ^tipe;
      tipe = real;

const rows : longint = 40;
      columns : longint = 30000;

var store : ^storage;

    y,x : longint; {y=1..40
                    x=1..30000}

    r : tipe;
    pr : ptipe;

begin
   new (store, init(rows*columns, sizeof(real)));
   if (store=nil) then
    begin
      writeln ('Out of memory.');
      exit;
    end;
   for y:=0 to rows-1 do
    for x:=0 to columns-1 do
     begin
      r:=y*columns+x;
      store^.put(y*columns+x, @r);
     end;
   for y:=0 to rows-1 do
    for x:=0 to columns-1 do
     begin
      store^.get(y*columns+x, pointer(pr));
      if (pr^<>y*columns+x) then
       begin
        writeln ('Error... (Hopefully Impossible)');
        break;
       end
      else write ('.');
     end;
   dispose (store, done);
end.